home *** CD-ROM | disk | FTP | other *** search
- /* farray.c zilla - c/foreign arrays for elk
- *
- Portions of this file are Copyright (C) 1991 John Lewis,
- adapted from Elk2.0 by Oliver Laumann.
-
- This file is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
- ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE. ALL C VARIABLES WHICH
- ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
- ****AFTER A GC.
- *
- * todo: add pointer subtype, list->farray&c
- * make reading know about array shape
- * note: considered adding a 'boolean(bit) subtype, decided no:
- * What would this provide over a 'string array whose
- * elements are used as bits? Only storage.
- * Need some way to set bits and then retrieve the byte
- * as an integer. This could be added to a 'boolean subtype,
- * but it is just as easy to make a (bit-compress <stringarr>)
- * function.
- * modified
- * 12nov
- * 17oct elk2
- * 7jul farray_make_like, farray_copyshape
- * 24jun bugfix in farray2double
- * 4jun farray-string conversion
- * 11may GC CORRECTED; shape reversed so shape[0] is minor.
- * 27apr farray-of can take bignum as well as fixnum
- * 13apr -flt, -int conversions now allow string farrays.
- * 12apr farray clength changed
- * 6apr farray->shape,ndim
- * 30jan farray-int,farray-flt
- * 20jan (farray-of <args>). CHECK- is gc ok on this!?
- * Also change print syntax to (% ... )
- * 2jan farray2double
- * 15oct added magic field to farray.
- * 8oct decided that 'string' arrays should appear as
- * byte integers 0..255 rather than as scheme #\chars-
- * more convenient for parsing byte image files.
- * Initialize arrays to zero only in farray-make, not
- * in arrays created by e.g. v-*.
- * 11sep bug-needed gc protection in several places!
- * ALSO needed object 'tag' in first element of structure!!
- */
-
-
- #include <theusual.h>
- #include <constants.h>
- #include <scheme.h>
- #include <assert.h>
- #include <zelk.h>
-
- #ifdef CONTAINS
- #define FARRAY(o) ((Farray *)POINTER(o))
-
- typedef struct farray {
- Object tag; /* needed by elk gc system */
- int type;
- int len;
- int shape[FARRAY_MAXDIM]; /* used by vector code, minor dim is [0] */
- int ndim; /* used by vector code */
- /* the magic field allows array code to be written for use inside or
- outside of scheme : given an array, test the previous word for magic.
- If so, call scheme to find the length. If not, obtain length
- from some global or assumption (vec library will work this way).
- */
- /* magic must be immediately before start of data! */
- int4 magic;
- Zbyte data[1];
- } Farray;
- #endif
-
- global int T_Farray;
-
- /* Return size in bytes of an farray. 1 is for checkbyte */
- #define FARRAYWHOLESIZE(type,len) \
- (sizeof(Farray) + ((type)==T_String ? (len) : (len)*4) + 1)
-
- /* size in bytes of just the data */
- #define FARRAYDATASIZE(type,len) \
- ((type)==T_String ? (len) : (len)*4)
-
- /* change VR.c if this changes !! */
- #define FARRAY_MAGIC 77
-
- #define Sym_integer Intern("integer")
- #define Sym_real Intern("real")
- #define Sym_string Intern("string")
-
- static char *ENotFarray = "argument is not farray";
-
- /**************** make &c ****/
-
- Object farray_make(type,len)
- int type;
- int len;
- {
- Object F;
- Farray *a;
- char *alias;
- int i;
- Ztrace(("farray_make type=%d len=%d\n",type,len));
-
- if ((type==T_String) || (type==T_Fixnum) || (type==T_Flonum)) /*nothing*/ ;
- else Panic("farray_make: bad type");
-
- F = Alloc_Object(FARRAYWHOLESIZE(type,len),T_Farray,0);
- a = FARRAY(F);
-
- a->tag = Null; /* used by the elk gc system */
- a->type = type;
- a->len = len;
- a->shape[0]=len;
- for( i=1; i < FARRAY_MAXDIM; i++ ) a->shape[i]=0;
- a->ndim=1;
- a->magic = FARRAY_MAGIC;
-
- /* DO NOT zero the array here. this routine gets called by both
- * the (farray-make) user-level function, and by the various vector
- * functions e.g. v-*. For the latter, the array is a return value
- * and will always be written into, so it is inefficient to
- * initialize it. Initialize in (farray-make) only.
- */
-
- alias = (char *)a;
- alias[FARRAYWHOLESIZE(type,len)-1] = FARRAY_MAGIC;
-
- return F;
- } /*make*/
-
-
- /* make an farray with same type and shape as A
- used often by fvector.c */
- Object farray_make_like(A)
- Object A;
- {
- Farray *a,*f;
- Object F;
- int i;
- int type,len;
- GC_Node;
-
- a = FARRAY(A);
- type = a->type;
- len = a->len;
-
- GC_Link(A);
- F = farray_make(type,len);
- GC_Unlink;
-
- a = FARRAY(A);
- f = FARRAY(F);
- f->ndim = a->ndim;
- for( i=0; i < a->ndim; i++ ) f->shape[i] = a->shape[i];
-
- return F;
- } /*make_like*/
-
-
- /* copy shape of A to B. used by vector code */
- void farray_copyshape(A,B)
- Object A,B;
- {
- register int i;
- register Farray *a,*b;
- Ztrace(("farray_copyshape\n"));
-
- a = FARRAY(A); b = FARRAY(B);
- if (b->len != a->len) Panic("farray_copyshape");
- b->ndim = a->ndim;
- for( i=0; i < a->ndim; i++ ) b->shape[i] = a->shape[i];
-
- Ztrace(("--farray_copyshape\n"));
- } /*copyshape*/
-
-
- Object P_farray_make(ptype,len)
- Object ptype,len;
- {
- int type;
- Object F;
- Farray *f;
- Error_Tag = "farray";
- #ifdef ztrace
- Print_Object(ptype,Standard_Output_Port,0,2,10);
- #endif
-
- if (ptype == Sym_real) type = T_Flonum;
- else if (ptype == Sym_integer) type = T_Fixnum;
- else if (ptype == Sym_string) type = T_String;
- else Primitive_Error("bad type");
-
- F = farray_make(type,Get_Integer(len));
- f = FARRAY(F);
-
- /* Initialize arrays created with this (farray-make) primitive */
- Zbzero((char *)f->data,((f->type)==T_String ? (f->len) : ((f->len)*4)));
-
- return F;
- } /*P_make*/
-
-
- void farray_check(f)
- Object f;
- {
- Farray *a;
- char *alias;
-
- Error_Tag = "farray-check";
- if (TYPE(f) != T_Farray) Primitive_Error(ENotFarray);
-
- a = FARRAY(f);
- alias = (char *)a;
-
- if ((a->magic != FARRAY_MAGIC) ||
- (alias[FARRAYWHOLESIZE(a->type,a->len)-1] != FARRAY_MAGIC))
- Primitive_Error("array is corrupted?");
- } /*_check*/
-
-
- Object P_farray_check(f)
- Object f;
- {
- farray_check(f);
- return Null;
- } /*_check*/
-
-
- Object P_farray_length(f)
- Object f;
- {
- Object rval;
- Error_Tag = "farray-length";
-
- Check_Type(f,T_Farray);
-
- rval = Make_Integer(FARRAY(f)->len);
-
- return rval;
- } /*P_length*/
-
-
- Object P_farrayp(f)
- Object f;
- {
- return (TYPE(f)==T_Farray) ? True : False;
- } /*P_p*/
-
-
- Object P_farray_type(f)
- Object f;
- {
- Farray *a;
-
- Error_Tag = "farray-type";
- if (TYPE(f) != T_Farray) Primitive_Error(ENotFarray);
-
- a = FARRAY(f);
- switch(a->type) {
- case T_Fixnum: return(Sym_integer); break;
- case T_Flonum: return(Sym_real); break;
- case T_String: return(Sym_string); break;
- default: Panic("farray_type");
- }
- return Null; /*for lint*/
- } /*P_type*/
-
-
- Object P_farray_copy(f)
- Object f;
- {
- Farray *a,*b;
- int i;
- Object f2;
- GC_Node;
- Error_Tag = "farray-copy";
-
- Check_Type(f,T_Farray);
-
- GC_Link(f);
- a = FARRAY(f);
- f2 = farray_make(a->type,a->len);
- GC_Unlink;
-
- a = FARRAY(f);
- b = FARRAY(f2);
-
- Zbcopy(a->data,b->data,FARRAYDATASIZE(a->type,a->len));
-
- /* shape is mainly used by vector code currently */
- for( i=0; i < FARRAY_MAXDIM; i++ ) b->shape[i] = a->shape[i];
- b->ndim = a->ndim;
-
- return f2;
- } /*copy*/
-
-
- /* make an farray from the provided arguments, e.g.,
- * (farray-of 2. 3.) => [ 2. 3. ]
- * Decided to NOT make this a special syntax for now-
- * Getting the reader to read the closing ] will require changes...
- * Instead, this is bound to the procedure %, and farrays are
- * also printed as (% .... ), so we have read-print equivalence.
- */
-
- /* WARNING- not sure if this routine is properly GC protected */
-
- Object P_farray_of (argc, argv)
- Object *argv;
- {
- Object F;
- Farray *f;
- int i,type;
- Error_Tag = "farray";
-
- if (argc < 1) Primitive_Error("no items in array");
-
- type = TYPE(argv[0]);
-
- if (type == T_Character)
- F = farray_make(T_String,argc);
- else if (type == T_String)
- F = farray_make(T_String,STRING(argv[0])->size);
- else if (type == T_Bignum)
- F = farray_make(T_Fixnum,argc);
- else
- F = farray_make(type,argc);
- f = FARRAY(F);
-
- switch(type) {
-
- case T_Flonum:
- for( i=0; i < argc; i++ ) {
- Check_Type(argv[i],T_Flonum);
- ((float *)f->data)[i] = FLONUM(argv[i])->val;
- }
- break;
-
- case T_Bignum:
- case T_Fixnum:
- for( i=0; i < argc; i++ ) {
- if ((TYPE(argv[i])!=T_Bignum) && (TYPE(argv[i]!=T_Fixnum)))
- Primitive_Error("mixed types in farray");
- ((int4 *)f->data)[i] = Get_Integer(argv[i]);
- }
- break;
-
- case T_Character:
- for( i=0; i < argc; i++ ) {
- Check_Type(argv[i],T_Character);
- ((char *)f->data)[i] = CHAR(argv[i]);
- }
- break;
-
- case T_String:
- for( i=0; i < STRING(argv[0])->size; i++ ) {
- ((char *)f->data)[i] = STRING(argv[0])->data[i];
- }
- break;
-
- } /*switch(type)*/
-
- return F;
- } /*farray-of */
-
-
-
- /**************** set and ref ****/
-
- Object P_farray_set(f,pidx,pobj)
- Object f,pidx,pobj;
- {
- int4 idx;
- Farray *a;
- long *L; float *F; unsigned char *C;
-
- Error_Tag = "farray-set!";
- Check_Type(f,T_Farray);
-
- a = FARRAY(f);
- C = (unsigned char *)a->data;
- F = (float *)a->data;
- L = (long *)a->data;
- idx = Get_Integer(pidx);
- if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");
-
- switch(a->type) {
- case T_Fixnum:
- L[idx] = Get_Integer(pobj);
- break;
- case T_Flonum:
- if (TYPE(pobj) != T_Flonum) Primitive_Error("bad type");
- F[idx] = (double)FLONUM(pobj)->val;
- break;
- case T_String:
- /* if (TYPE(pobj) != T_Character) Primitive_Error("bad type");
- C[idx] = (char)CHAR(pobj); */
- C[idx] = (unsigned char)Get_Integer(pobj);
- break;
- default: Panic("farray_set");
- }
-
- return pobj;
- } /*P_set*/
-
-
-
- Object P_farray_ref(f,pidx)
- Object f,pidx;
- {
- int4 idx;
- Farray *a;
- long *L; float *F; unsigned char *C;
- Object val;
- Error_Tag = "farray-ref";
-
- Check_Type(f,T_Farray);
-
- a = FARRAY(f);
- C = (unsigned char *)a->data;
- F = (float *)a->data;
- L = (long *)a->data;
-
- idx = Get_Integer(pidx);
- if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");
-
- switch(a->type) {
- case T_Fixnum:
- val = Make_Integer((int4)L[idx]);
- break;
- case T_Flonum:
- val = Make_Reduced_Flonum(F[idx]);
- break;
- case T_String:
- /* val = Make_Char(C[idx]); */
- val = Make_Integer((int4)C[idx]);
- break;
- default: Panic("farray_ref");
- }
-
- return val;
- } /*P_ref*/
-
- /**************** routines called from c programs! ****
- **** when a c program is passed an array but no size,
- **** call these to get the size/type.
- */
-
-
- /* given the start of the array data, back up to get the array header.
- * This does not work, probably because of structure alignment.
- * ((Farray *)((char *)a - (sizeof(Farray)-sizeof(char))))
- * This is wierd, but it will work regardless of changes in Farray struct:
- */
- static Farray _Junk;
- #define FARRAYHDR(a) \
- ((Farray *)((char *)a - ((char *)&_Junk.data[0] - (char *)&_Junk.tag)))
-
-
- int farray_clength(a)
- long *a;
- {
- Farray *o;
-
- o = FARRAYHDR(a);
- if (o->magic == FARRAY_MAGIC)
- return(o->len);
- else
- return -1;
- }
-
-
- int farray_ctype(a)
- long *a;
- {
- Farray *o;
-
- o = FARRAYHDR(a);
- if (o->magic == FARRAY_MAGIC)
- return(o->type);
- else
- Panic("farray_ctype");
- }
-
- /*%%%%%%%%%%%%%%%% routines used by elk type creation system %%%%*/
-
- static int4 farray_size(f)
- Object f;
- {
- Farray *a;
- if (TYPE(f) != T_Farray) Panic("farray_size");
- a = FARRAY(f);
- return( FARRAYWHOLESIZE(a->type,a->len) );
- }
-
-
- bool farray_equal(a,b)
- Object a,b;
- {
- return 0;
- }
-
-
- void farray_print(f,port,raw,pdepth,plen)
- Object f;
- Object port;
- bool raw; /* does what? */
- int pdepth, plen;
- {
- Farray *a;
- int type,len;
- int4 *L;
- float *F;
- char *format;
-
- if (TYPE(f) != T_Farray) Panic("farray_print");
- a = FARRAY(f);
- type = a->type;
- len = a->len;
-
- switch (type) {
- case T_Fixnum: format = "%d "; break;
- case T_Flonum: format = "%.3f "; break;
- case T_String: break;
- default: Panic ("farray:print");
- } /*switch*/
-
- F = (float *)a->data;
- /* since floats are converted to doubles whenever passed,
- * floats,int4s cannot both be handled with a long *.
- */
- L = (int4 *)a->data;
-
- if (type == T_String) {
- register int i;
- register char *c,*d;
-
- c = (char *)a->data;
- d = Ctmpbuf;
- if (len >= Ctmpbuflen) Panic("farray_print: string too long");
-
- for( i=0; i < len; i++ ) {
- /* do not print null characters */
- if (*c != (char)0) *d++ = *c;
- c++;
- }
- *d = (char)0;
-
- Printf(port,"[%s]",Ctmpbuf);
- } /*string*/
-
- else if (a->ndim == 2) { /* print as matrix */
- register int i,j;
- for (i = 0; i < a->shape[1]; i++) {
- Printf(port, "[ ");
- for (j = 0; j < a->shape[0]; j++) {
- if (type == T_Flonum)
- (void)sprintf (Ctmpbuf, format, *F++);
- else
- (void)sprintf (Ctmpbuf, format, *L++);
- Printf(port, Ctmpbuf);
- }
- Printf(port, "]\n");
- }
- } /*matrix*/
-
-
- else {
- register int i;
- Printf(port, "(%% ");
-
- for (i = 0; i < len; i++) {
-
- if (i > plen) { /* too big, stop printing */
- Printf(port,"...");
- break;
- }
- if (type == T_Flonum)
- (void)sprintf (Ctmpbuf, format, *F++);
- else
- (void)sprintf (Ctmpbuf, format, *L++);
- Printf(port, Ctmpbuf);
- }
- Printf(port, ")");
- } /*print as array */
-
- } /*_print*/
-
-
- /**************** type conversion ****************/
-
- /* convert float or string array to int */
- #define FARRAY_INT P_farray_int, "farray-int", 1,1,EVAL,
- Object
- P_farray_int(A)
- Object A;
- {
- register int i,len;
- Object B;
- Farray *a;
- register int4 *ib;
- GC_Node;
- Error_Tag = "farray-int";
-
- Check_Type(A,T_Farray);
-
- a = FARRAY(A);
- /* already integer. return a copy to stay functional- caller may
- be expecting that result is a distinct array */
- if (a->type == T_Fixnum) return P_farray_copy(A);
- len = a->len;
-
- GC_Link(A);
- B = farray_make(T_Fixnum,len);
- GC_Unlink;
- a = FARRAY(A); /* reassign after gc */
- ib = (int4 *)FARRAY(B)->data;
-
- if (a->type == T_Flonum) {
- register float *ia = (float *)a->data;
- for( i=0; i < len; i++ ) *ib++ = (int4)*ia++;
- }
- else if (a->type == T_String) {
- register unsigned char *ia = (unsigned char *)a->data;
- for( i=0; i < len; i++ ) *ib++ = (int4)*ia++;
- }
- else Panic("farray-int");
-
- return B;
- } /*int*/
-
-
-
- /* convert float or int array to string(byte) */
- #define FARRAY_STRING P_farray_string, "farray-string", 1,1,EVAL,
- Object
- P_farray_string(A)
- Object A;
- {
- register int i,len;
- Object B;
- Farray *a;
- register unsigned char *ib;
- GC_Node;
- Error_Tag = "farray-string";
-
- Check_Type(A,T_Farray);
-
- a = FARRAY(A);
- /* already string. return a copy to stay functional- caller may
- be expecting that result is a distinct array */
- if (a->type == T_String) return P_farray_copy(A);
- len = a->len;
-
- GC_Link(A);
- B = farray_make(T_String,len);
- GC_Unlink;
- a = FARRAY(A); /* reassign after gc */
- ib = (unsigned char *)FARRAY(B)->data;
-
- if (a->type == T_Flonum) {
- register float *ia = (float *)a->data;
- for( i=0; i < len; i++ ) *ib++ = (unsigned char)(int)*ia++;
- }
- else if (a->type == T_Fixnum) {
- register int *ia = (int *)a->data;
- for( i=0; i < len; i++ ) *ib++ = (unsigned char)*ia++;
- }
- else Panic("farray-string");
-
- return B;
- } /*string*/
-
-
- /* convert int or string farray to float */
- #define FARRAY_FLT P_farray_flt, "farray-flt", 1,1,EVAL,
- Object P_farray_flt(A)
- Object A;
- {
- register int i,len;
- Object B;
- Farray *a;
- register float *ib;
- GC_Node;
- Error_Tag = "farray-flt";
-
- Check_Type(A,T_Farray);
-
- a = FARRAY(A);
- /* already float. return a copy to stay functional- caller may
- be expecting that result is a distinct array */
- if (a->type == T_Flonum) return P_farray_copy(A); /* already float */
- len = a->len;
-
- GC_Link(A);
- B = farray_make(T_Flonum,len);
- GC_Unlink;
- a = FARRAY(A); /* reassign after gc! */
- ib = (float *)FARRAY(B)->data;
-
- if (a->type == T_Fixnum) {
- register int4 *ia = (int4 *)a->data;
- for( i=0; i < len; i++ ) *ib++ = (float)*ia++;
- }
- else if (a->type == T_String) {
- register unsigned char *ia = (unsigned char *)a->data;
- register int j;
- /* some c compiler could not cast from char to float directly */
- for( i=0; i < len; i++ ) {
- j = *ia++;
- *ib++ = (float)j;
- }
- }
- else Panic("farray-flt");
-
- return B;
- } /*flt*/
-
-
- /* convert a float farray to the same, of 2x length, containing doubles */
- Object P_farray2double(F)
- Object F;
- {
- Object D;
- Farray *f,*d;
- float *fp; double *dp;
- int i,len;
- GC_Node;
- Error_Tag = "farray2double";
-
- if (FARRAY(F)->type != T_Flonum)
- Primitive_Error("array is not float");
-
- GC_Link(F);
- D = farray_make(T_Flonum,FARRAY(F)->len*2);
- GC_Unlink;
-
- f = FARRAY(F);
- d = FARRAY(D);
- fp = (float *)f->data;
- dp = (double *)d->data;
- len = f->len;
-
- for( i=0; i < len; i++ ) {
- *dp++ = (double)*fp++;
- }
-
- return D;
- } /*P_double*/
-
-
- /**************** link ****************/
-
- static struct primdef Prims[] = {
- FARRAY_INT
- FARRAY_STRING
- FARRAY_FLT
-
- (Object (*)())0, (char *)0, 0,0,EVAL
- };
-
-
- void Init_farray()
- {
- T_Farray = Define_Type(0,"farray",farray_size,0,
- farray_equal,farray_equal,
- farray_print, NOFUNC);
- /* printf("[Init_farray type %d]\n",T_Farray); */
-
- Define_Primitive(P_farray_make,"farray",2,2,EVAL);
- Define_Primitive(P_farrayp,"farray?",1,1,EVAL);
- Define_Primitive(P_farray_check,"farray-check",1,1,EVAL);
-
- Define_Primitive(P_farray_length,"farray-length",1,1,EVAL);
- Define_Primitive(P_farray_type,"farray-type",1,1,EVAL);
- Define_Primitive(P_farray_copy,"farray-copy",1,1,EVAL);
-
- Define_Primitive(P_farray_of,"farray-of",0,MANY,VARARGS);
- Define_Primitive(P_farray_of,"%",0,MANY,VARARGS); /*synonym*/
-
- Define_Primitive(P_farray_set,"farray-set!",3,3,EVAL);
- Define_Primitive(P_farray_ref,"farray-ref",2,2,EVAL);
-
- Define_Primitive(P_farray2double,"farray2double",1,1,EVAL);
-
- ZLprimdeftab(Prims);
-
- P_Provide(Intern("farray.o"));
- } /*init*/
-